home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / exp-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.6 KB  |  232 lines  |  [TEXT/CCL2]
  1. ;;; File: expr-parser           Author: John
  2.  
  3. (define (parse-exp)
  4.  (trace-parser exp
  5.    (parse-exp-0)))
  6.  
  7. (define (parse-exp-0)  ;; This picks up expr type signatures
  8.   (let ((exp (parse-exp-i)))
  9.     (token-case
  10.      (\:\: (let ((signature (parse-signature)))
  11.          (make exp-sign (exp exp) (signature signature))))
  12.    (else exp))))
  13.  
  14. (define (parse-exp-i)  ;; This collects a list of exps for later prec parsing
  15.   (let ((exps (parse-infix-exps)))
  16.     (if (null? (cdr exps))
  17.     (car exps)
  18.     (make pp-exp-list (exps exps)))))
  19.  
  20. (define (parse-infix-exps)
  21.   (token-case
  22.      (- (cons (make negate) (parse-infix-exps)))
  23.      (\\ (list (parse-lambda)))
  24.      (|let| (list (parse-let)))
  25.      (|if| (list (parse-if)))
  26.      (|case| (parse-possible-app (parse-case)))
  27.      (else (let ((aexp (parse-aexp)))
  28.          (parse-possible-app aexp)))))
  29.  
  30. (define (parse-possible-app exp)
  31.   (token-case
  32.     (aexp-start
  33.      (let ((exp2 (parse-aexp)))
  34.       (parse-possible-app (make app (fn exp) (arg exp2)))))
  35.     (varop
  36.      (let ((varop (varop->ast)))
  37.        (if (eq-token? '\))
  38.        (list exp varop)
  39.        `(,exp ,varop ,@(parse-infix-exps)))))
  40.     (conop
  41.      (let ((conop (conop->ast)))
  42.        (if (eq-token? '\))
  43.        (list exp conop)
  44.        `(,exp ,conop ,@(parse-infix-exps)))))
  45.     (else (list exp))))
  46.  
  47. (define (parse-lambda)
  48.   (trace-parser lambda
  49.    (save-parser-context
  50.     (let ((pats (parse-apat-list)))
  51.       (require-token -> (signal-missing-token "`->'" "lambda expression"))
  52.       (let ((exp (parse-exp)))
  53.     (make lambda (pats pats) (body exp)))))))
  54.  
  55. (define (parse-let)
  56.   (trace-parser let
  57.    (save-parser-context
  58.     (let ((decls (parse-decl-list)))
  59.       (require-token |in| (signal-missing-token "`in'" "let expression"))
  60.       (let ((exp (parse-exp)))
  61.     (make let (decls decls) (body exp)))))))
  62.  
  63. (define (parse-if)
  64.   (trace-parser if
  65.    (save-parser-context
  66.     (let ((test-exp (parse-exp)))
  67.       (require-token |then| (signal-missing-token "`then'" "if expression"))
  68.       (let ((then-exp (parse-exp)))
  69.     (require-token |else| (signal-missing-token "`else'" "if expression"))
  70.     (let ((else-exp (parse-exp)))
  71.       (make if (test-exp test-exp)
  72.            (then-exp then-exp)
  73.            (else-exp else-exp))))))))
  74.  
  75. (define (parse-case)
  76.   (trace-parser case
  77.    (save-parser-context
  78.     (let ((exp (parse-exp)))
  79.       (require-token |of| (signal-missing-token "`of'" "case expression"))
  80.       (let ((alts (start-layout (function parse-alts))))
  81.     (make case (exp exp) (alts alts)))))))
  82.  
  83. (define (parse-alts in-layout?)
  84.   (token-case
  85.     (pat-start
  86.      (let ((alt (parse-alt)))
  87.        (token-case
  88.     (\; (cons alt (parse-alts in-layout?)))
  89.     (else (close-layout in-layout?)
  90.           (list alt)))))
  91.     (else
  92.      (close-layout in-layout?)
  93.      '())))
  94.  
  95. (define (parse-alt)
  96.  (trace-parser alt
  97.   (let* ((pat (parse-pat))
  98.      (rhs-list (token-case
  99.             (-> (let ((exp (parse-exp)))
  100.               (list (make guarded-rhs (guard (make omitted-guard))
  101.                                   (rhs exp)))))
  102.             (\| (parse-guarded-alt-rhs))
  103.             (else (signal-missing-token "`->' or `|'" "rhs of alt"))))
  104.      (decls (parse-where-decls)))
  105.     (make alt (pat pat) (rhs-list rhs-list) (where-decls decls)))))
  106.  
  107. (define (parse-guarded-alt-rhs)
  108.   (let ((guard (parse-exp)))
  109.     (require-token -> (signal-missing-token "`->'" "alt"))
  110.     (let* ((exp (parse-exp))
  111.        (res (make guarded-rhs (guard guard) (rhs exp))))
  112.       (token-case
  113.        (\| (cons res (parse-guarded-alt-rhs)))
  114.        (else (list res))))))
  115.  
  116. (define (parse-aexp)
  117.  (trace-parser aexp
  118.   (token-case
  119.     (var (save-parser-context (var->ast)))
  120.     (con (save-parser-context (con->ast)))
  121.     (literal (literal->ast))
  122.     (_ (save-parser-context (make bottom)))
  123.     (\(
  124.      (token-case
  125.        (\) (**con/def (core-symbol "UnitConstructor")))
  126.        ((no-advance -) (parse-exp-or-tuple))
  127.        (varop
  128.     (let ((varop (varop->ast)))
  129.       (make-right-section varop)))
  130.        (conop
  131.     (let ((conop (conop->ast)))
  132.       (make-right-section conop)))
  133.        (else
  134.     (parse-exp-or-tuple))))
  135.     (\[
  136.      (token-case
  137.       (\] (make list-exp (exps '())))
  138.       (else
  139.        (let ((exp (parse-exp)))
  140.         (token-case
  141.          (\, (let ((exp2 (parse-exp)))
  142.            (token-case
  143.          (\] (make list-exp (exps (list exp exp2))))
  144.          (\.\. (token-case
  145.              (\] (make sequence-then (from exp) (then exp2)))
  146.              (else
  147.                (let ((exp3 (parse-exp)))
  148.                  (require-token
  149.                    \]
  150.                    (signal-missing-token
  151.                  "`]'" "sequence expression"))
  152.                  (make sequence-then-to (from exp) (then exp2)
  153.                                     (to exp3))))))
  154.          (else
  155.           (make list-exp
  156.             (exps `(,exp ,exp2 ,@(parse-exp-list))))))))
  157.      (\.\. (token-case
  158.          (\] (make sequence (from exp)))
  159.          (else
  160.           (let ((exp2 (parse-exp)))
  161.             (require-token
  162.               \]
  163.               (signal-missing-token "`]'" "sequence expression"))
  164.             (make sequence-to (from exp) (to exp2))))))
  165.      (\] (make list-exp (exps (list exp))))
  166.      (\| (parse-list-comp exp))
  167.      (else
  168.       (signal-invalid-syntax
  169.         "a list, sequence, or list comprehension")))))))
  170.     (else
  171.      (signal-invalid-syntax "an aexp")))))
  172.  
  173. (define (make-right-section op)
  174.   (let ((exps (parse-infix-exps)))
  175.     (token-case
  176.      (\) (make pp-exp-list (exps (cons op exps))))
  177.      (else (signal-missing-token "`)'" "right section expression")))))
  178.  
  179. (define (parse-exp-list)
  180.   (token-case
  181.    (\] '())
  182.    (\, (let ((exp (parse-exp))) (cons exp (parse-exp-list))))
  183.    (else (signal-missing-token "`]' or `,'" "list expression"))))
  184.  
  185. (define (parse-exp-or-tuple)
  186.   (let ((exp (parse-exp)))
  187.     (token-case
  188.      (\) exp)  ; Note - sections ending in an op are parsed elsewhere
  189.      (else (make-tuple-cons (cons exp (parse-tuple-exp)))))))
  190.  
  191. (define (parse-tuple-exp)
  192.   (token-case
  193.    (\) '())
  194.    (\, (let ((exp (parse-exp))) (cons exp (parse-tuple-exp))))
  195.    (else (signal-missing-token
  196.       "`)' or `,'" "tuple or parenthesized expression"))))
  197.  
  198. ;;; List comprehensions
  199.  
  200. ;;; Assume | has been consumed
  201.  
  202. (define (parse-list-comp exp)
  203.  (save-parser-context 
  204.   (let ((quals (parse-qual-list)))
  205.     (make list-comp (exp exp) (quals quals)))))
  206.  
  207. (define (parse-qual-list)
  208.   (let ((qual (parse-qual)))
  209.     (token-case
  210.       (\, (cons qual (parse-qual-list)))
  211.       (\] (list qual))
  212.       (else (signal-missing-token "`]' or `,'" "list comprehension")))))
  213.  
  214. (define (parse-qual)
  215.  (trace-parser qual
  216.   (save-parser-context 
  217.    (let* ((saved-excursion (save-scanner-state))
  218.       (is-gen? (and (scan-pat) (eq-token? '<-))))
  219.     (restore-excursion saved-excursion)
  220.     (cond (is-gen?
  221.        (let ((pat (parse-pat)))
  222.          (advance-token) ; past the <-
  223.          (let ((exp (parse-exp)))
  224.            (make qual-generator (pat pat) (exp exp)))))
  225.       (else
  226.        (let ((exp (parse-exp)))
  227.          (make qual-filter (exp exp)))))))))
  228.  
  229. (define (make-tuple-cons args)
  230.   (let ((tuple-con (**con/def (tuple-constructor (length args)))))
  231.     (**app/l tuple-con args)))
  232.